home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / buffer.l < prev    next >
Text File  |  1988-09-12  |  46KB  |  1,288 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the BUFFER object for Common-Lisp X
  4. ;;; windows version 11
  5.  
  6. ;;;
  7. ;;;             TEXAS INSTRUMENTS INCORPORATED
  8. ;;;                  P.O. BOX 2909
  9. ;;;                   AUSTIN, TEXAS 78769
  10. ;;;
  11. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  12. ;;;
  13. ;;; Permission is granted to any individual or institution to use, copy, modify,
  14. ;;; and distribute this software, provided that this complete copyright and
  15. ;;; permission notice is maintained, intact, in all copies and supporting
  16. ;;; documentation.
  17. ;;;
  18. ;;; Texas Instruments Incorporated provides this software "as is" without
  19. ;;; express or implied warranty.
  20. ;;;
  21.  
  22. ;; A few notes:
  23. ;;
  24. ;;  1. The BUFFER implements a two-way buffered byte / half-word
  25. ;;     / word stream.  Hooks are left for implementing this with a
  26. ;;     shared memory buffer, or with effenciency hooks to the network
  27. ;;     code.
  28. ;;
  29. ;;  2. The BUFFER object uses overlapping displaced arrays for
  30. ;;     inserting and removing bytes half-words and words.
  31. ;;
  32. ;;  3. The BYTE component of these arrays is written to a STREAM
  33. ;;     associated with the BUFFER.  The stream has its own buffer.
  34. ;;     This may be made more efficient by using the Zetalisp
  35. ;;     :Send-Output-Buffer operation.
  36. ;;
  37. ;;  4. The BUFFER object is INCLUDED in the DISPLAY object.
  38. ;;     This was done to reduce access time when sending requests,
  39. ;;     while maintaing some code modularity.
  40. ;;     Several buffer functions are duplicated (with-buffer,
  41. ;;     buffer-force-output, close-buffer) to keep the naming
  42. ;;     conventions consistent.
  43. ;;
  44. ;;  5. A nother layer of software is built on top of this for generating
  45. ;;     both client and server interface routines, given a specification
  46. ;;     of the protocol. (see the INTERFACE file)
  47. ;;
  48. ;;  6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
  49. ;;     a point after a complete request.  This is to ensure that a partial
  50. ;;     request won't be left after aborts (e.g. control-abort on a lispm).
  51.  
  52. (in-package 'xlib :use '(lisp))
  53.  
  54. (defparameter *requestsize* 160) ;; Max request size (excluding variable length requests)
  55.  
  56. (eval-when (eval compile load)
  57.  
  58. ;;; This is here instead of in bufmac so that with-display can be
  59. ;;; compiled without macros and bufmac being loaded.
  60.  
  61. (defmacro with-buffer ((buffer) &body body)
  62.   ;; This macro is for use in a multi-process environment.  It provides
  63.   ;; exclusive access to the local buffer object for request generation and
  64.   ;; reply processing.
  65.   (declare (special *within-with-buffer*))
  66.   (if (and (boundp '*within-with-buffer*) *within-with-buffer*)
  67.       `(progn ,buffer ,@body) ;; Speedup hack for lexically nested with-buffer's
  68.     `(compiler-let ((*within-with-buffer* t))
  69.        (let ()
  70.      (declare-bufmac)
  71.      (holding-lock ((buffer-lock ,buffer) "Display-Lock") ,@body)))))
  72.  
  73. ;;; The following are here instead of in bufmac so that event-case can
  74. ;;; be compiled without macros and bufmac being loaded.
  75.  
  76. (defmacro read-card8 (byte-index)
  77.   `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  78.  
  79. (defmacro read-int8 (byte-index)
  80.   `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  81.  
  82. (defmacro read-card16 (byte-index)
  83.   #+clx-overlapping-arrays
  84.   `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  85.   #-clx-overlapping-arrays
  86.   `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  87.  
  88. (defmacro read-int16 (byte-index)
  89.   #+clx-overlapping-arrays
  90.   `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  91.   #-clx-overlapping-arrays
  92.   `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  93.  
  94. (defmacro read-card32 (byte-index)
  95.   #+clx-overlapping-arrays
  96.   `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  97.   #-clx-overlapping-arrays
  98.   `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  99.  
  100. (defmacro read-int32 (byte-index)
  101.   #+clx-overlapping-arrays
  102.   `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  103.   #-clx-overlapping-arrays
  104.   `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  105.  
  106. (defmacro read-card29 (byte-index)
  107.   #+clx-overlapping-arrays
  108.   `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  109.   #-clx-overlapping-arrays
  110.   `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  111.  
  112. (defmacro event-code (reply-buffer)
  113.   ;; The reply-buffer structure is used for events.
  114.   ;; The size slot is used for the event code.
  115.   `(reply-size ,reply-buffer))
  116.  
  117. (defmacro reading-event ((event &rest options) &body body)
  118.   (declare-arglist (buffer &key sizes) &body body)
  119.   ;; BODY may contain calls to (READ32 &optional index) etc.
  120.   ;; These calls will read from the input buffer at byte
  121.   ;; offset INDEX.  If INDEX is not supplied, then the next
  122.   ;; word, half-word or byte is returned.
  123.   (let ((reply-buffer (gensym)))
  124.     `(let ((,reply-buffer ,event))
  125.        (with-buffer-input (,reply-buffer ,@options) ,@body))))
  126.  
  127. (defmacro with-buffer-input ((buffer &key (sizes '(8 16 32)) index) &body body)
  128.   (unless (listp sizes) (setq sizes (list sizes)))
  129.   ;; 160 is a special hack for client-message-events
  130.   (when (set-difference sizes '(0 8 16 32 160 256))
  131.     (error "Illegal sizes in ~a" sizes))
  132.   `(let ()
  133.      (declare-bufmac)
  134.      (let* ((buffer-boffset (the array-index ,(or index 0)))
  135.         ,@(when (or #-clx-overlapping-arrays t (member 8 sizes))
  136.         `((buffer-bbuf (reply-ibuf8 ,buffer))))
  137.         #+clx-overlapping-arrays
  138.         ,@(when (or (member 16 sizes) (member 160 sizes))
  139.         `((buffer-woffset (index-ash buffer-boffset -1))
  140.           (buffer-wbuf (reply-ibuf16 ,buffer))))
  141.         #+clx-overlapping-arrays
  142.         ,@(when (member 32 sizes)
  143.         `((buffer-loffset (index-ash buffer-boffset -2))
  144.           (buffer-lbuf (reply-ibuf32 ,buffer)))))
  145.        ,@(when (or #-clx-overlapping-arrays t (member '8 sizes))
  146.        '((declare-array buffer-bytes buffer-bbuf)))
  147.        #+clx-overlapping-arrays
  148.        ,@(when (member '16 sizes)
  149.        '((declare-array buffer-words buffer-wbuf)))
  150.        #+clx-overlapping-arrays
  151.        ,@(when (member '32 sizes)
  152.        '((declare-array buffer-longs buffer-lbuf)))
  153.        buffer-boffset
  154.        ,@(when (or #-clx-overlapping-arrays t (member 8 sizes)) '(buffer-bbuf))
  155.        #+clx-overlapping-arrays
  156.        ,@(when (member 16 sizes) '(buffer-woffset buffer-wbuf))
  157.        #+clx-overlapping-arrays
  158.        ,@(when (member 32 sizes) '(buffer-loffset buffer-lbuf))
  159.        ,@body)))
  160.  
  161. )
  162.  
  163. (defun make-buffer (input-size output-size constructor &rest options)
  164.   ;; Input-size is the reply-buffer size in bytes,
  165.   ;; Output-Size is the output-buffer size in bytes.
  166.   (let ((byte-output (make-array output-size :element-type 'card8
  167.                  :initial-element 0)))
  168.     (apply constructor
  169.        :limit (index- output-size *requestsize*)
  170.        :size output-size
  171.        :obuf8 byte-output
  172.        #+clx-overlapping-arrays
  173.        :obuf16
  174.        #+clx-overlapping-arrays
  175.        (make-array (index-ash output-size -1)
  176.                :element-type 'overlap16
  177.                :displaced-to byte-output)
  178.        #+clx-overlapping-arrays
  179.        :obuf32
  180.        #+clx-overlapping-arrays
  181.        (make-array (index-ash output-size -2)
  182.                :element-type 'overlap32
  183.                :displaced-to byte-output)
  184.        :reply-buffer (make-reply-buffer input-size)
  185.        options)))
  186.  
  187. (defun make-reply-buffer (size)
  188.   ;; Size is the buffer size in bytes
  189.   (let ((byte-input (make-array size :element-type 'card8
  190.                 :initial-element 0)))
  191.     (make-reply-buffer-internal
  192.       :size size
  193.       :ibuf8 byte-input
  194.       #+clx-overlapping-arrays
  195.       :ibuf16
  196.       #+clx-overlapping-arrays
  197.       (make-array (index-ash size -1)
  198.           :element-type 'overlap16
  199.           :displaced-to byte-input)
  200.       #+clx-overlapping-arrays
  201.       :ibuf32
  202.       #+clx-overlapping-arrays
  203.       (make-array (index-ash size -2)
  204.           :element-type 'overlap32
  205.           :displaced-to byte-input))))
  206. ;;
  207. ;; Buffer stream operations
  208. ;;
  209.  
  210. (defun buffer-write (vector buffer start end)
  211.   ;; Write out VECTOR from START to END into BUFFER
  212.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  213.   (declare (type buffer buffer)
  214.        (type array-index start end))
  215.   (when (buffer-dead buffer)
  216.     (x-error 'closed-display :display buffer))
  217.   (wrap-buf-output buffer
  218.     (funcall (buffer-write-function buffer) vector buffer start end))
  219.   nil)
  220.  
  221. (defun buffer-flush (buffer)
  222.   ;; Write the buffer contents to the server stream - doesn't force-output the stream
  223.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  224.   (declare (type buffer buffer))
  225.   (let ((boffset (buffer-boffset buffer)))
  226.     (declare (type array-index boffset))
  227.     (when (index-plusp boffset)
  228.       (buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
  229.       (setf (buffer-boffset buffer) 0)
  230.       (setf (buffer-last-request buffer) nil)))
  231.   nil)
  232.  
  233. (defun buffer-force-output (buffer)
  234.   ;; Output is normally buffered, this forces any buffered output to the server.
  235.   (declare (type buffer buffer))
  236.   (when (buffer-dead buffer)
  237.     (x-error 'closed-display :display buffer))
  238.   (buffer-flush buffer)
  239.   (wrap-buf-output buffer
  240.     (funcall (buffer-force-output-function buffer) buffer))
  241.   nil)
  242.  
  243. (defun close-buffer (buffer)
  244.   ;; Close the host connection in BUFFER
  245.   (declare (type buffer buffer))
  246.   (unless (null (buffer-output-stream buffer))
  247.     (wrap-buf-output buffer
  248.       (funcall (buffer-close-function buffer) buffer))
  249.     (setf (buffer-dead buffer) t)
  250.     ;; Zap pointers to the streams, to ensure they're GC'd
  251.     (setf (buffer-output-stream buffer) nil)
  252.     (setf (buffer-input-stream buffer) nil)
  253.     )
  254.   nil)
  255.  
  256. (defun buffer-input  (buffer vector start end &optional timeout)
  257.   ;; Read into VECTOR from the buffer stream
  258.   ;; Timeout, when non-nil, is in seconds
  259.   ;; Returns non-nil if EOF encountered
  260.   ;; Returns :TIMEOUT when timeout exceeded
  261.   (declare (type buffer buffer)
  262.        (type vector vector)
  263.        (type array-index start end)
  264.        (type (or null number) timeout))
  265.   (declare-values eof-p)
  266.   (when (buffer-dead buffer)
  267.     (x-error 'closed-display :display buffer))
  268.   (unless (= start end)
  269.     (funcall (buffer-input-function buffer) buffer vector start end timeout)))
  270.  
  271. ;;; Reading sequences of strings
  272.  
  273. ;;; a list of pascal-strings with card8 lengths, no padding in between
  274. ;;; can't use read-sequence-char
  275. (defun read-sequence-string (buffer length nitems result-type)
  276.   (declare (type buffer buffer)
  277.        (type array-index length nitems))
  278.   (let ((result (make-sequence result-type nitems)))
  279.     (reading-buffer-reply (buffer :sizes 8)
  280.       (do* ((string-index 0)
  281.         (string-left-to-read 0)
  282.         (string "")
  283.         (sequence-index 0)
  284.         (size (reply-size (buffer-reply-buffer buffer)))
  285.         (len length (index- len chunk))
  286.         (chunk (index-min size len) (index-min size len)))
  287.        ((index-zerop len) result)
  288.     (declare (type array-index string-index string-left-to-read sequence-index
  289.                size len chunk)
  290.          (type simple-string string))
  291.     (buffer-input buffer buffer-bbuf 0 (lround chunk))
  292.     (do ((buffer-index 0 (index+ buffer-index 1))
  293.          (card8 0))
  294.         ((index>= buffer-index chunk))
  295.       (declare (type array-index buffer-index)
  296.            (type card8 card8))
  297.       (setq card8 (read-card8 buffer-index))
  298.       (if (index-zerop string-left-to-read)
  299.           (when (index< sequence-index nitems)
  300.         (setq string-left-to-read card8)
  301.         (setq string (make-string string-left-to-read))
  302.         (setq string-index 0)
  303.         (setf (elt result sequence-index) string)
  304.         (setq sequence-index (index+ sequence-index 1)))
  305.         (progn
  306.           (setf (aref string string-index) (the string-char (card8->char card8)))
  307.           (setq string-index (index+ string-index 1))
  308.           (setq string-left-to-read (index- string-left-to-read 1)))))))))
  309.  
  310. ;;; Reading sequences of chars
  311.  
  312. (defun read-sequence-char (buffer result-type nitems &optional transform data (start 0))
  313.   (declare (type buffer buffer)
  314.        (type t result-type) ;; CL type
  315.        (type array-index nitems start)
  316.        (type (or null sequence) data))
  317.   (declare-funarg (or null (function (character) t)) transform)
  318.   (if transform 
  319.       (read-sequence-card8
  320.     buffer result-type nitems
  321.     #'(lambda (v)
  322.         (declare (type card8 v))
  323.         (funcall transform (card8->char v)))
  324.     data
  325.     start)
  326.     (read-sequence-card8 buffer result-type nitems #'card8->char data start)))
  327.  
  328. ;;; Reading sequences of card8's
  329.  
  330. (defun read-list-card8 (buffer nitems data start)
  331.   (declare (type buffer buffer)
  332.        (type array-index nitems start)
  333.        (type list data))
  334.   (reading-buffer-chunks card8
  335.     (do* ((j chunk (index- j 1))
  336.       (lst (nthcdr i data) (cdr lst))
  337.       (index 0 (index+ index 1)))
  338.      ((index-zerop j))
  339.       (declare (type array-index j index)
  340.            (type cons lst))
  341.       (setf (car lst) (read-card8 index)))))
  342.  
  343. (defun read-list-card8-with-transform (buffer nitems data transform start)
  344.   (declare (type buffer buffer)
  345.        (type array-index nitems start)
  346.        (type list data))
  347.   (declare-funarg (function (card8) t) transform)
  348.   (reading-buffer-chunks card8
  349.     (do* ((j chunk (index- j 1))
  350.       (lst (nthcdr i data) (cdr lst))
  351.       (index 0 (index+ index 1)))
  352.      ((index-zerop j))
  353.       (declare (type array-index j index)
  354.            (type cons lst))
  355.       (setf (car lst) (funcall transform (read-card8 index))))))
  356.  
  357. #-lispm
  358. (defun read-simple-array-card8 (buffer nitems data start)
  359.   (declare (type buffer buffer)
  360.        (type array-index nitems start)
  361.        (type (simple-array card8 (*)) data))
  362.   (with-vector (data (simple-array card8 (*)))
  363.     (reading-buffer-chunks card8
  364.       (buffer-replace data buffer-bbuf i end))))
  365.  
  366. #-lispm
  367. (defun read-simple-array-card8-with-transform (buffer nitems data transform start)
  368.   (declare (type buffer buffer)
  369.        (type array-index nitems start)
  370.        (type (simple-array card8 (*)) data))
  371.   (declare-funarg (function (card8) card8) transform)
  372.   (with-vector (data (simple-array card8 (*)))
  373.     (reading-buffer-chunks card8
  374.       (do* ((j i (index+ j 1))
  375.         (index 0 (index+ index 1)))
  376.        ((index>= j end))
  377.     (declare (type array-index j index))
  378.     (setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
  379.  
  380. (defun read-vector-card8 (buffer nitems data start)
  381.   (declare (type buffer buffer)
  382.        (type array-index nitems start)
  383.        (type vector data))
  384.   (with-vector (data vector)
  385.     (reading-buffer-chunks card8
  386.       (buffer-replace data buffer-bbuf i end))))
  387.  
  388. (defun read-vector-card8-with-transform (buffer nitems data transform start)
  389.   (declare (type buffer buffer)
  390.        (type array-index nitems start)
  391.        (type vector data))
  392.   (declare-funarg (function (card8) t) transform)
  393.   (with-vector (data vector)
  394.     (reading-buffer-chunks card8
  395.       (do* ((j i (index+ j 1))
  396.         (index 0 (index+ index 1)))
  397.        ((index>= j end))
  398.     (declare (type array-index j index))
  399.     (setf (aref data j) (funcall transform (read-card8 index)))))))
  400.  
  401. (defun read-sequence-card8 (buffer result-type nitems &optional transform data (start 0))
  402.   (declare (type buffer buffer)
  403.        (type t result-type) ;; CL type
  404.        (type array-index nitems start)
  405.        (type (or null sequence) data))
  406.   (declare-funarg (or null (function (card8) t)) transform)
  407.   (let ((result (or data (make-sequence result-type nitems))))
  408.     (typecase result
  409.       (list
  410.     (if transform 
  411.         (read-list-card8-with-transform buffer nitems result transform start)
  412.       (read-list-card8 buffer nitems result start)))
  413.       #-lispm
  414.       ((simple-array card8 (*))
  415.        (if transform 
  416.        (read-simple-array-card8-with-transform buffer nitems result transform start)
  417.      (read-simple-array-card8 buffer nitems result start)))
  418.       (t
  419.     (if transform 
  420.         (read-vector-card8-with-transform buffer nitems result transform start)
  421.       (read-vector-card8 buffer nitems result start))))
  422.     result))
  423.  
  424. ;;; For now, perhaps performance it isn't worth doing better?
  425.  
  426. (defun read-sequence-int8 (buffer result-type nitems &optional transform data (start 0))
  427.   (declare (type buffer buffer)
  428.        (type t result-type) ;; CL type
  429.        (type array-index nitems start)
  430.        (type (or null sequence) data))
  431.   (declare-funarg (or null (function (int8) t)) transform)
  432.   (if transform 
  433.       (read-sequence-card8
  434.     buffer result-type nitems
  435.     #'(lambda (v)
  436.         (declare (type card8 v))
  437.         (funcall transform (card8->int8 v)))
  438.     data
  439.     start)
  440.     (read-sequence-card8 buffer result-type nitems #'card8->int8 data start)))
  441.  
  442. ;;; Reading sequences of card16's
  443.  
  444. (defun read-list-card16 (buffer nitems data start)
  445.   (declare (type buffer buffer)
  446.        (type array-index nitems start)
  447.        (type list data))
  448.   (reading-buffer-chunks card16
  449.     (do* ((j chunk (index- j 1))
  450.       (lst (nthcdr i data) (cdr lst))
  451.       (index 0 (index+ index 2)))
  452.      ((index-zerop j))
  453.       (declare (type array-index j index)
  454.            (type cons lst))
  455.       (setf (car lst) (read-card16 index)))))
  456.  
  457. (defun read-list-card16-with-transform (buffer nitems data transform start)
  458.   (declare (type buffer buffer)
  459.        (type array-index nitems start)
  460.        (type list data))
  461.   (declare-funarg (function (card16) t) transform)
  462.   (reading-buffer-chunks card16
  463.     (do* ((j chunk (index- j 1))
  464.       (lst (nthcdr i data) (cdr lst))
  465.       (index 0 (index+ index 2)))
  466.      ((index-zerop j))
  467.       (declare (type array-index j index)
  468.            (type cons lst))
  469.       (setf (car lst) (funcall transform (read-card16 index))))))
  470.  
  471. #-lispm
  472. (defun read-simple-array-card16 (buffer nitems data start)
  473.   (declare (type buffer buffer)
  474.        (type array-index nitems start)
  475.        (type (simple-array card16 (*)) data))
  476.   (with-vector (data (simple-array card16 (*)))
  477.     (reading-buffer-chunks card16
  478.       (do* ((j i (index+ j 1))
  479.         (index 0 (index+ index 2)))
  480.        ((index>= j end))
  481.     (declare (type array-index j index))
  482.     (setf (aref data j) (the card16 (read-card16 index))))
  483.       ;; overlapping case
  484.       (buffer-replace data buffer-wbuf i end))))
  485.  
  486. #-lispm
  487. (defun read-simple-array-card16-with-transform (buffer nitems data transform start)
  488.   (declare (type buffer buffer)
  489.        (type array-index nitems start)
  490.        (type (simple-array card16 (*)) data))
  491.   (declare-funarg (function (card16) card16) transform)
  492.   (with-vector (data (simple-array card16 (*)))
  493.     (reading-buffer-chunks card16
  494.       (do* ((j i (index+ j 1))
  495.         (index 0 (index+ index 2)))
  496.        ((index>= j end))
  497.     (declare (type array-index j index))
  498.     (setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
  499.  
  500. (defun read-vector-card16 (buffer nitems data start)
  501.   (declare (type buffer buffer)
  502.        (type array-index nitems start)
  503.        (type vector data))
  504.   (with-vector (data vector)
  505.     (reading-buffer-chunks card16
  506.       (do* ((j i (index+ j 1))
  507.         (index 0 (index+ index 2)))
  508.        ((index>= j end))
  509.     (declare (type array-index j index))
  510.     (setf (aref data j) (read-card16 index)))
  511.       ;; overlapping case
  512.       (buffer-replace data buffer-wbuf i end))))
  513.  
  514. (defun read-vector-card16-with-transform (buffer nitems data transform start)
  515.   (declare (type buffer buffer)
  516.        (type array-index nitems start)
  517.        (type vector data))
  518.   (declare-funarg (function (card16) t) transform)
  519.   (with-vector (data vector)
  520.     (reading-buffer-chunks card16
  521.       (do* ((j i (index+ j 1))
  522.         (index 0 (index+ index 2)))
  523.        ((index>= j end))
  524.     (declare (type array-index j index))
  525.     (setf (aref data j) (funcall transform (read-card16 index)))))))
  526.  
  527. (defun read-sequence-card16 (buffer result-type nitems &optional transform data (start 0))
  528.   (declare (type buffer buffer)
  529.        (type t result-type) ;; CL type
  530.        (type array-index nitems start)
  531.        (type (or null sequence) data))
  532.   (declare-funarg (or null (function (card16) t)) transform)
  533.   (let ((result (or data (make-sequence result-type nitems))))
  534.     (typecase result
  535.       (list
  536.     (if transform 
  537.         (read-list-card16-with-transform buffer nitems result transform start)
  538.       (read-list-card16 buffer nitems result start)))
  539.       #-lispm
  540.       ((simple-array card16 (*))
  541.        (if transform 
  542.        (read-simple-array-card16-with-transform buffer nitems result transform start)
  543.      (read-simple-array-card16 buffer nitems result start)))
  544.       (t
  545.     (if transform 
  546.         (read-vector-card16-with-transform buffer nitems result transform start)
  547.       (read-vector-card16 buffer nitems result start))))
  548.     result))
  549.   
  550. ;;; For now, perhaps performance it isn't worth doing better?
  551.  
  552. (defun read-sequence-int16 (buffer result-type nitems &optional transform data (start 0))
  553.   (declare (type buffer buffer)
  554.        (type t result-type) ;; CL type
  555.        (type array-index nitems start)
  556.        (type (or null sequence) data))
  557.   (declare-funarg (or null (function (int16) t)) transform)
  558.   (if transform 
  559.       (read-sequence-card16
  560.     buffer result-type nitems
  561.     #'(lambda (v)
  562.         (declare (type card16 v))
  563.         (funcall transform (card16->int16 v)))
  564.     data
  565.     start)
  566.     (read-sequence-card16 buffer result-type nitems #'card16->int16 data start)))
  567.  
  568. ;;; Reading sequences of card32's
  569.  
  570. (defun read-list-card32 (buffer nitems data start)
  571.   (declare (type buffer buffer)
  572.        (type array-index nitems start)
  573.        (type list data))
  574.   (reading-buffer-chunks card32
  575.     (do* ((j chunk (index- j 1))
  576.       (lst (nthcdr i data) (cdr lst))
  577.       (index 0 (index+ index 4)))
  578.      ((index-zerop j))
  579.       (declare (type array-index j index)
  580.            (type cons lst))
  581.       (setf (car lst) (read-card32 index)))))
  582.  
  583. (defun read-list-card32-with-transform (buffer nitems data transform start)
  584.   (declare (type buffer buffer)
  585.        (type array-index nitems start)
  586.        (type list data))
  587.   (declare-funarg (function (card32) t) transform)
  588.   (reading-buffer-chunks card32
  589.     (do* ((j chunk (index- j 1))
  590.       (lst (nthcdr i data) (cdr lst))
  591.       (index 0 (index+ index 4)))
  592.      ((index-zerop j))
  593.       (declare (type array-index j index)
  594.            (type cons lst))
  595.       (setf (car lst) (funcall transform (read-card32 index))))))
  596.  
  597. #-lispm
  598. (defun read-simple-array-card32 (buffer nitems data start)
  599.   (declare (type buffer buffer)
  600.        (type array-index nitems start)
  601.        (type (simple-array card32 (*)) data))
  602.   (with-vector (data (simple-array card32 (*)))
  603.     (reading-buffer-chunks card32
  604.       (do* ((j i (index+ j 1))
  605.         (index 0 (index+ index 4)))
  606.        ((index>= j end))
  607.     (declare (type array-index j index))
  608.     (setf (aref data j) (the card32 (read-card32 index))))
  609.       ;; overlapping case
  610.       (buffer-replace data buffer-lbuf i end))))
  611.  
  612. #-lispm
  613. (defun read-simple-array-card32-with-transform (buffer nitems data transform start)
  614.   (declare (type buffer buffer)
  615.        (type array-index nitems start)
  616.        (type (simple-array card32 (*)) data))
  617.   (declare-funarg (function (card32) card32) transform)
  618.   (with-vector (data (simple-array card32 (*)))
  619.     (reading-buffer-chunks card32
  620.       (do* ((j i (index+ j 1))
  621.         (index 0 (index+ index 4)))
  622.        ((index>= j end))
  623.     (declare (type array-index j index))
  624.     (setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
  625.  
  626. (defun read-vector-card32 (buffer nitems data start)
  627.   (declare (type buffer buffer)
  628.        (type array-index nitems start)
  629.        (type vector data))
  630.   (with-vector (data vector)
  631.     (reading-buffer-chunks card32
  632.       (do* ((j i (index+ j 1))
  633.         (index 0 (index+ index 4)))
  634.        ((index>= j end))
  635.     (declare (type array-index j index))
  636.     (setf (aref data j) (read-card32 index)))
  637.       ;; overlapping case
  638.       (buffer-replace data buffer-lbuf i end))))
  639.  
  640. (defun read-vector-card32-with-transform (buffer nitems data transform start)
  641.   (declare (type buffer buffer)
  642.        (type array-index nitems start)
  643.        (type vector data))
  644.   (declare-funarg (function (card32) t) transform)
  645.   (with-vector (data vector)
  646.     (reading-buffer-chunks card32
  647.       (do* ((j i (index+ j 1))
  648.         (index 0 (index+ index 4)))
  649.        ((index>= j end))
  650.     (declare (type array-index j index))
  651.     (setf (aref data j) (funcall transform (read-card32 index)))))))
  652.  
  653. (defun read-sequence-card32 (buffer result-type nitems &optional transform data (start 0))
  654.   (declare (type buffer buffer)
  655.        (type t result-type) ;; CL type
  656.        (type array-index nitems start)
  657.        (type (or null sequence) data))
  658.   (declare-funarg (or null (function (card32) t)) transform)
  659.   (let ((result (or data (make-sequence result-type nitems))))
  660.     (typecase result
  661.       (list
  662.     (if transform 
  663.         (read-list-card32-with-transform buffer nitems result transform start)
  664.       (read-list-card32 buffer nitems result start)))
  665.       #-lispm
  666.       ((simple-array card32 (*))
  667.        (if transform 
  668.        (read-simple-array-card32-with-transform buffer nitems result transform start)
  669.      (read-simple-array-card32 buffer nitems result start)))
  670.       (t
  671.     (if transform 
  672.         (read-vector-card32-with-transform buffer nitems result transform start)
  673.       (read-vector-card32 buffer nitems result start))))
  674.     result))
  675.  
  676. ;;; For now, perhaps performance it isn't worth doing better?
  677.  
  678. (defun read-sequence-int32 (buffer result-type nitems &optional transform data (start 0))
  679.   (declare (type buffer buffer)
  680.        (type t result-type) ;; CL type
  681.        (type array-index nitems start)
  682.        (type (or null sequence) data))
  683.   (declare-funarg (or null (function (int32) t)) transform)
  684.   (if transform 
  685.       (read-sequence-card32
  686.     buffer result-type nitems
  687.     #'(lambda (v)
  688.         (declare (type card32 v))
  689.         (funcall transform (card32->int32 v)))
  690.     data
  691.     start)
  692.     (read-sequence-card32 buffer result-type nitems #'card32->int32 data start)))
  693.  
  694. ;;; Writing sequences of chars
  695.  
  696. (defun write-sequence-char
  697.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  698.   (declare (type buffer buffer)
  699.        (type sequence data)
  700.        (type array-index boffset start end))
  701.   (declare-funarg (or null (function (t) character)) transform)
  702.   (if transform 
  703.       (write-sequence-card8
  704.     buffer boffset data start end
  705.     #'(lambda (x) (char->card8 (the character (funcall transform x)))))
  706.     (write-sequence-card8 buffer boffset data start end #'char->card8)))
  707.  
  708. ;;; Writing sequences of card8's
  709.  
  710. (defun write-list-card8 (buffer boffset data start end)
  711.   (declare (type buffer buffer)
  712.        (type list data)
  713.        (type array-index boffset start end))
  714.   (writing-buffer-chunks card8
  715.              ((lst (nthcdr start data)))
  716.              ((type list lst))
  717.     (dotimes (j chunk)
  718.       (declare (type array-index j))
  719.       (write-card8 j (pop lst))))
  720.   nil)
  721.  
  722. (defun write-list-card8-with-transform (buffer boffset data start end transform)
  723.   (declare (type buffer buffer)
  724.        (type list data)
  725.        (type array-index boffset start end))
  726.   (declare-funarg (function (t) card8) transform)
  727.   (writing-buffer-chunks card8
  728.              ((lst (nthcdr start data)))
  729.              ((type list lst))
  730.     (dotimes (j chunk)
  731.       (declare (type array-index j))
  732.       (write-card8 j (funcall transform (pop lst)))))
  733.   nil)
  734.  
  735. ;;; Should really write directly from data, instead of into the buffer first
  736. #-lispm
  737. (defun write-simple-array-card8 (buffer boffset data start end)
  738.   (declare (type buffer buffer)
  739.        (type (simple-array card8 (*)) data)
  740.        (type array-index boffset start end))
  741.   (with-vector (data (simple-array card8 (*)))
  742.     (writing-buffer-chunks card8
  743.                ((index start (index+ index chunk)))
  744.                ((type array-index index))
  745.       (buffer-replace buffer-bbuf data
  746.               buffer-boffset
  747.               (index+ buffer-boffset chunk)
  748.               index)))
  749.   nil)
  750.  
  751. #-lispm
  752. (defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
  753.   (declare (type buffer buffer)
  754.        (type (simple-array card8 (*)) data)
  755.        (type array-index boffset start end))
  756.   (declare-funarg (function (card8) card8) transform)
  757.   (with-vector (data (simple-array card8 (*)))
  758.     (writing-buffer-chunks card8
  759.                ((index start))
  760.                ((type array-index index))
  761.       (dotimes (j chunk)
  762.     (declare (type array-index j))
  763.     (write-card8 j (funcall transform (aref data index)))
  764.     (setq index (index+ index 1)))))
  765.   nil)
  766.  
  767. (defun write-vector-card8 (buffer boffset data start end)
  768.   (declare (type buffer buffer)
  769.        (type vector data)
  770.        (type array-index boffset start end))
  771.   (with-vector (data vector)
  772.     (writing-buffer-chunks card8
  773.                ((index start (index+ index chunk)))
  774.                ((type array-index index))
  775.       (buffer-replace buffer-bbuf data
  776.               buffer-boffset
  777.               (index+ buffer-boffset chunk)
  778.               index)))
  779.   nil)
  780.  
  781. (defun write-vector-card8-with-transform (buffer boffset data start end transform)
  782.   (declare (type buffer buffer)
  783.        (type vector data)
  784.        (type array-index boffset start end))
  785.   (declare-funarg (function (t) card8) transform)
  786.   (with-vector (data vector)
  787.     (writing-buffer-chunks card8
  788.                ((index start))
  789.                ((type array-index index))
  790.       (dotimes (j chunk)
  791.     (declare (type array-index j))
  792.     (write-card8 j (funcall transform (aref data index)))
  793.     (setq index (index+ index 1)))))
  794.   nil)
  795.  
  796. (defun write-sequence-card8
  797.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  798.   (declare (type buffer buffer)
  799.        (type sequence data)
  800.        (type array-index boffset start end))
  801.   (declare-funarg (or null (function (t) card8)) transform)
  802.   (typecase data
  803.     (list
  804.       (if transform
  805.       (write-list-card8-with-transform buffer boffset data start end transform)
  806.       (write-list-card8 buffer boffset data start end)))
  807.     #-lispm
  808.     ((simple-array card8 (*))
  809.      (if transform
  810.      (write-simple-array-card8-with-transform buffer boffset data start end transform)
  811.      (write-simple-array-card8 buffer boffset data start end)))
  812.     (t
  813.       (if transform
  814.       (write-vector-card8-with-transform buffer boffset data start end transform)
  815.       (write-vector-card8 buffer boffset data start end)))))
  816.  
  817. ;;; For now, perhaps performance it isn't worth doing better?
  818.  
  819. (defun write-sequence-int8
  820.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  821.   (declare (type buffer buffer)
  822.        (type sequence data)
  823.        (type array-index boffset start end))
  824.   (declare-funarg (or null (function (t) int8)) transform)
  825.   (if transform 
  826.       (write-sequence-card8
  827.     buffer boffset start end
  828.     #'(lambda (x) (int8->card8 (the int8 (funcall transform x))))
  829.     data)
  830.       (write-sequence-card8 buffer boffset start end #'int8->card8)))
  831.  
  832. ;;; Writing sequences of card16's
  833.  
  834. (defun write-list-card16 (buffer boffset data start end)
  835.   (declare (type buffer buffer)
  836.        (type list data)
  837.        (type array-index boffset start end))
  838.   (writing-buffer-chunks card16
  839.              ((lst (nthcdr start data)))
  840.              ((type list lst))
  841.     ;; Depends upon the chunks being an even multiple of card16's big
  842.     (do ((j 0 (index+ j 2)))
  843.     ((index>= j chunk))
  844.       (declare (type array-index j))
  845.       (write-card16 j (pop lst))))
  846.   nil)
  847.  
  848. (defun write-list-card16-with-transform (buffer boffset data start end transform)
  849.   (declare (type buffer buffer)
  850.        (type list data)
  851.        (type array-index boffset start end))
  852.   (declare-funarg (function (t) card16) transform)
  853.   (writing-buffer-chunks card16
  854.              ((lst (nthcdr start data)))
  855.              ((type list lst))
  856.     ;; Depends upon the chunks being an even multiple of card16's big
  857.     (do ((j 0 (index+ j 2)))
  858.     ((index>= j chunk))
  859.       (declare (type array-index j))
  860.       (write-card16 j (funcall transform (pop lst)))))
  861.   nil)
  862.  
  863. #-lispm
  864. (defun write-simple-array-card16 (buffer boffset data start end)
  865.   (declare (type buffer buffer)
  866.        (type (simple-array card16 (*)) data)
  867.        (type array-index boffset start end))
  868.   (with-vector (data (simple-array card16 (*)))
  869.     (writing-buffer-chunks card16
  870.                ((index start))
  871.                ((type array-index index))
  872.       ;; Depends upon the chunks being an even multiple of card16's big
  873.       (do ((j 0 (index+ j 2)))
  874.       ((index>= j chunk))
  875.     (declare (type array-index j))
  876.     (write-card16 j (aref data index))
  877.     (setq index (index+ index 1)))
  878.       ;; overlapping case
  879.       (let ((length (floor chunk 2)))
  880.     (buffer-replace buffer-wbuf data
  881.             buffer-woffset
  882.             (index+ buffer-woffset length)
  883.             index)
  884.     (setq index (index+ index length)))))
  885.   nil)
  886.  
  887. #-lispm
  888. (defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
  889.   (declare (type buffer buffer)
  890.        (type (simple-array card16 (*)) data)
  891.        (type array-index boffset start end))
  892.   (declare-funarg (function (card16) card16) transform)
  893.   (with-vector (data (simple-array card16 (*)))
  894.     (writing-buffer-chunks card16
  895.                ((index start))
  896.                ((type array-index index))
  897.       ;; Depends upon the chunks being an even multiple of card16's big
  898.       (do ((j 0 (index+ j 2)))
  899.       ((index>= j chunk))
  900.     (declare (type array-index j))
  901.     (write-card16 j (funcall transform (aref data index)))
  902.     (setq index (index+ index 1)))))
  903.   nil)
  904.  
  905. (defun write-vector-card16 (buffer boffset data start end)
  906.   (declare (type buffer buffer)
  907.        (type vector data)
  908.        (type array-index boffset start end))
  909.   (with-vector (data vector)
  910.     (writing-buffer-chunks card16
  911.                ((index start))
  912.                ((type array-index index))
  913.       ;; Depends upon the chunks being an even multiple of card16's big
  914.       (do ((j 0 (index+ j 2)))
  915.       ((index>= j chunk))
  916.     (declare (type array-index j))
  917.     (write-card16 j (aref data index))
  918.     (setq index (index+ index 1)))
  919.       ;; overlapping case
  920.       (let ((length (floor chunk 2)))
  921.     (buffer-replace buffer-wbuf data
  922.             buffer-woffset
  923.             (index+ buffer-woffset length)
  924.             index)
  925.     (setq index (index+ index length)))))
  926.   nil)
  927.  
  928. (defun write-vector-card16-with-transform (buffer boffset data start end transform)
  929.   (declare (type buffer buffer)
  930.        (type vector data)
  931.        (type array-index boffset start end))
  932.   (declare-funarg (function (t) card16) transform)
  933.   (with-vector (data vector)
  934.     (writing-buffer-chunks card16
  935.                ((index start))
  936.                ((type array-index index))
  937.       ;; Depends upon the chunks being an even multiple of card16's big
  938.       (do ((j 0 (index+ j 2)))
  939.       ((index>= j chunk))
  940.     (declare (type array-index j))
  941.     (write-card16 j (funcall transform (aref data index)))
  942.     (setq index (index+ index 1)))))
  943.   nil)
  944.  
  945. (defun write-sequence-card16
  946.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  947.   (declare (type buffer buffer)
  948.        (type sequence data)
  949.        (type array-index boffset start end))
  950.   (declare-funarg (or null (function (t) card16)) transform)
  951.   (typecase data
  952.     (list
  953.       (if transform
  954.       (write-list-card16-with-transform buffer boffset data start end transform)
  955.       (write-list-card16 buffer boffset data start end)))
  956.     #-lispm
  957.     ((simple-array card16 (*))
  958.      (if transform
  959.      (write-simple-array-card16-with-transform buffer boffset data start end transform)
  960.      (write-simple-array-card16 buffer boffset data start end)))
  961.     (t
  962.       (if transform
  963.       (write-vector-card16-with-transform buffer boffset data start end transform)
  964.       (write-vector-card16 buffer boffset data start end)))))
  965.  
  966. ;;; Writing sequences of int16's
  967.  
  968. (defun write-list-int16 (buffer boffset data start end)
  969.   (declare (type buffer buffer)
  970.        (type list data)
  971.        (type array-index boffset start end))
  972.   (writing-buffer-chunks int16
  973.              ((lst (nthcdr start data)))
  974.              ((type list lst))
  975.     ;; Depends upon the chunks being an even multiple of int16's big
  976.     (do ((j 0 (index+ j 2)))
  977.     ((index>= j chunk))
  978.       (declare (type array-index j))
  979.       (write-int16 j (pop lst))))
  980.   nil)
  981.  
  982. (defun write-list-int16-with-transform (buffer boffset data start end transform)
  983.   (declare (type buffer buffer)
  984.        (type list data)
  985.        (type array-index boffset start end))
  986.   (declare-funarg (function (t) int16) transform)
  987.   (writing-buffer-chunks int16
  988.              ((lst (nthcdr start data)))
  989.              ((type list lst))
  990.     ;; Depends upon the chunks being an even multiple of int16's big
  991.     (do ((j 0 (index+ j 2)))
  992.     ((index>= j chunk))
  993.       (declare (type array-index j))
  994.       (write-int16 j (funcall transform (pop lst)))))
  995.   nil)
  996.  
  997. #-lispm
  998. (defun write-simple-array-int16 (buffer boffset data start end)
  999.   (declare (type buffer buffer)
  1000.        (type (simple-array int16 (*)) data)
  1001.        (type array-index boffset start end))
  1002.   (with-vector (data (simple-array int16 (*)))
  1003.     (writing-buffer-chunks int16
  1004.                ((index start))
  1005.                ((type array-index index))
  1006.       ;; Depends upon the chunks being an even multiple of int16's big
  1007.       (do ((j 0 (index+ j 2)))
  1008.       ((index>= j chunk))
  1009.     (declare (type array-index j))
  1010.     (write-int16 j (aref data index))
  1011.     (setq index (index+ index 1)))
  1012.       ;; overlapping case
  1013.       (let ((length (floor chunk 2)))
  1014.     (buffer-replace buffer-wbuf data
  1015.             buffer-woffset
  1016.             (index+ buffer-woffset length)
  1017.             index)
  1018.     (setq index (index+ index length)))))
  1019.   nil)
  1020.  
  1021. #-lispm
  1022. (defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
  1023.   (declare (type buffer buffer)
  1024.        (type (simple-array int16 (*)) data)
  1025.        (type array-index boffset start end))
  1026.   (declare-funarg (function (int16) int16) transform)
  1027.   (with-vector (data (simple-array int16 (*)))
  1028.     (writing-buffer-chunks int16
  1029.                ((index start))
  1030.                ((type array-index index))
  1031.       ;; Depends upon the chunks being an even multiple of int16's big
  1032.       (do ((j 0 (index+ j 2)))
  1033.       ((index>= j chunk))
  1034.     (declare (type array-index j))
  1035.     (write-int16 j (funcall transform (aref data index)))
  1036.     (setq index (index+ index 1)))))
  1037.   nil)
  1038.  
  1039. (defun write-vector-int16 (buffer boffset data start end)
  1040.   (declare (type buffer buffer)
  1041.        (type vector data)
  1042.        (type array-index boffset start end))
  1043.   (with-vector (data vector)
  1044.     (writing-buffer-chunks int16
  1045.                ((index start))
  1046.                ((type array-index index))
  1047.       ;; Depends upon the chunks being an even multiple of int16's big
  1048.       (do ((j 0 (index+ j 2)))
  1049.       ((index>= j chunk))
  1050.     (declare (type array-index j))
  1051.     (write-int16 j (aref data index))
  1052.     (setq index (index+ index 1)))
  1053.       ;; overlapping case
  1054.       (let ((length (floor chunk 2)))
  1055.     (buffer-replace buffer-wbuf data
  1056.             buffer-woffset
  1057.             (index+ buffer-woffset length)
  1058.             index)
  1059.     (setq index (index+ index length)))))
  1060.   nil)
  1061.  
  1062. (defun write-vector-int16-with-transform (buffer boffset data start end transform)
  1063.   (declare (type buffer buffer)
  1064.        (type vector data)
  1065.        (type array-index boffset start end))
  1066.   (declare-funarg (function (t) int16) transform)
  1067.   (with-vector (data vector)
  1068.     (writing-buffer-chunks int16
  1069.                ((index start))
  1070.                ((type array-index index))
  1071.       ;; Depends upon the chunks being an even multiple of int16's big
  1072.       (do ((j 0 (index+ j 2)))
  1073.       ((index>= j chunk))
  1074.     (declare (type array-index j))
  1075.     (write-int16 j (funcall transform (aref data index)))
  1076.     (setq index (index+ index 1)))))
  1077.   nil)
  1078.  
  1079. (defun write-sequence-int16
  1080.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1081.   (declare (type buffer buffer)
  1082.        (type sequence data)
  1083.        (type array-index boffset start end))
  1084.   (declare-funarg (or null (function (t) int16)) transform)
  1085.   (typecase data
  1086.     (list
  1087.       (if transform
  1088.       (write-list-int16-with-transform buffer boffset data start end transform)
  1089.       (write-list-int16 buffer boffset data start end)))
  1090.     #-lispm
  1091.     ((simple-array int16 (*))
  1092.      (if transform
  1093.      (write-simple-array-int16-with-transform buffer boffset data start end transform)
  1094.      (write-simple-array-int16 buffer boffset data start end)))
  1095.     (t
  1096.       (if transform
  1097.       (write-vector-int16-with-transform buffer boffset data start end transform)
  1098.       (write-vector-int16 buffer boffset data start end)))))
  1099.  
  1100. ;;; Writing sequences of card32's
  1101.  
  1102. (defun write-list-card32 (buffer boffset data start end)
  1103.   (declare (type buffer buffer)
  1104.        (type list data)
  1105.        (type array-index boffset start end))
  1106.   (writing-buffer-chunks card32
  1107.              ((lst (nthcdr start data)))
  1108.              ((type list lst))
  1109.     ;; Depends upon the chunks being an even multiple of card32's big
  1110.     (do ((j 0 (index+ j 4)))
  1111.     ((index>= j chunk))
  1112.       (declare (type array-index j))
  1113.       (write-card32 j (pop lst))))
  1114.   nil)
  1115.  
  1116. (defun write-list-card32-with-transform (buffer boffset data start end transform)
  1117.   (declare (type buffer buffer)
  1118.        (type list data)
  1119.        (type array-index boffset start end))
  1120.   (declare-funarg (function (t) card32) transform)
  1121.   (writing-buffer-chunks card32
  1122.              ((lst (nthcdr start data)))
  1123.              ((type list lst))
  1124.     ;; Depends upon the chunks being an even multiple of card32's big
  1125.     (do ((j 0 (index+ j 4)))
  1126.     ((index>= j chunk))
  1127.       (declare (type array-index j))
  1128.       (write-card32 j (funcall transform (pop lst)))))
  1129.   nil)
  1130.  
  1131. #-lispm
  1132. (defun write-simple-array-card32 (buffer boffset data start end)
  1133.   (declare (type buffer buffer)
  1134.        (type (simple-array card32 (*)) data)
  1135.        (type array-index boffset start end))
  1136.   (with-vector (data (simple-array card32 (*)))
  1137.     (writing-buffer-chunks card32
  1138.                ((index start))
  1139.                ((type array-index index))
  1140.       ;; Depends upon the chunks being an even multiple of card32's big
  1141.       (do ((j 0 (index+ j 4)))
  1142.       ((index>= j chunk))
  1143.     (declare (type array-index j))
  1144.     (write-card32 j (aref data index))
  1145.     (setq index (index+ index 1)))
  1146.       ;; overlapping case
  1147.       (let ((length (floor chunk 4)))
  1148.     (buffer-replace buffer-lbuf data
  1149.             buffer-loffset
  1150.             (index+ buffer-loffset length)
  1151.             index)
  1152.     (setq index (index+ index length)))))
  1153.   nil)
  1154.  
  1155. #-lispm
  1156. (defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
  1157.   (declare (type buffer buffer)
  1158.        (type (simple-array card32 (*)) data)
  1159.        (type array-index boffset start end))
  1160.   (declare-funarg (function (card32) card32) transform)
  1161.   (with-vector (data (simple-array card32 (*)))
  1162.     (writing-buffer-chunks card32
  1163.                ((index start))
  1164.                ((type array-index index))
  1165.       ;; Depends upon the chunks being an even multiple of card32's big
  1166.       (do ((j 0 (index+ j 4)))
  1167.       ((index>= j chunk))
  1168.     (declare (type array-index j))
  1169.     (write-card32 j (funcall transform (aref data index)))
  1170.     (setq index (index+ index 1)))))
  1171.   nil)
  1172.  
  1173. (defun write-vector-card32 (buffer boffset data start end)
  1174.   (declare (type buffer buffer)
  1175.        (type vector data)
  1176.        (type array-index boffset start end))
  1177.   (with-vector (data vector)
  1178.     (writing-buffer-chunks card32
  1179.                ((index start))
  1180.                ((type array-index index))
  1181.       ;; Depends upon the chunks being an even multiple of card32's big
  1182.       (do ((j 0 (index+ j 4)))
  1183.       ((index>= j chunk))
  1184.     (declare (type array-index j))
  1185.     (write-card32 j (aref data index))
  1186.     (setq index (index+ index 1)))
  1187.       ;; overlapping case
  1188.       (let ((length (floor chunk 4)))
  1189.     (buffer-replace buffer-lbuf data
  1190.             buffer-loffset
  1191.             (index+ buffer-loffset length)
  1192.             index)
  1193.     (setq index (index+ index length)))))
  1194.   nil)
  1195.  
  1196. (defun write-vector-card32-with-transform (buffer boffset data start end transform)
  1197.   (declare (type buffer buffer)
  1198.        (type vector data)
  1199.        (type array-index boffset start end))
  1200.   (declare-funarg (function (t) card32) transform)
  1201.   (with-vector (data vector)
  1202.     (writing-buffer-chunks card32
  1203.                ((index start))
  1204.                ((type array-index index))
  1205.       ;; Depends upon the chunks being an even multiple of card32's big
  1206.       (do ((j 0 (index+ j 4)))
  1207.       ((index>= j chunk))
  1208.     (declare (type array-index j))
  1209.     (write-card32 j (funcall transform (aref data index)))
  1210.     (setq index (index+ index 1)))))
  1211.   nil)
  1212.  
  1213. (defun write-sequence-card32
  1214.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1215.   (declare (type buffer buffer)
  1216.        (type sequence data)
  1217.        (type array-index boffset start end))
  1218.   (declare-funarg (or null (function (t) card32)) transform)
  1219.   (typecase data
  1220.     (list
  1221.       (if transform
  1222.       (write-list-card32-with-transform buffer boffset data start end transform)
  1223.       (write-list-card32 buffer boffset data start end)))
  1224.     #-lispm
  1225.     ((simple-array card32 (*))
  1226.      (if transform
  1227.      (write-simple-array-card32-with-transform buffer boffset data start end transform)
  1228.      (write-simple-array-card32 buffer boffset data start end)))
  1229.     (t
  1230.       (if transform
  1231.       (write-vector-card32-with-transform buffer boffset data start end transform)
  1232.       (write-vector-card32 buffer boffset data start end)))))
  1233.  
  1234. ;;; For now, perhaps performance it isn't worth doing better?
  1235.  
  1236. (defun write-sequence-int32
  1237.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1238.   (declare (type buffer buffer)
  1239.        (type sequence data)
  1240.        (type array-index boffset start end))
  1241.   (declare-funarg (or null (function (t) int32)) transform)
  1242.   (if transform 
  1243.       (write-sequence-card32
  1244.     buffer boffset start end
  1245.     #'(lambda (x) (int32->card32 (the int32 (funcall transform x))))
  1246.     data)
  1247.       (write-sequence-card32 buffer boffset start end #'int32->card32)))
  1248.  
  1249. (defun read-bitvector256 (buffer-bbuf boffset data)
  1250.   (declare (type buffer-bytes buffer-bbuf)
  1251.        (type array-index boffset)
  1252.        (type (or null (simple-bit-vector 256)) data))
  1253.   (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
  1254.     (declare-array (simple-bit-vector 256) result)
  1255.     (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
  1256.      (j 8 (index+ j 8)))
  1257.     ((index>= j 256))
  1258.       (declare (type array-index i j))
  1259.       (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
  1260.        (k j (index+ k 1)))
  1261.       ((zerop byte)
  1262.        (when data ;; Clear uninitialized bits in data
  1263.          (do ((end (index+ j 8)))
  1264.          ((= k end))
  1265.            (setf (aref result k) 0)
  1266.            (index-incf k))))
  1267.     (declare (type array-index k)
  1268.          (type card8 byte))
  1269.     (setf (aref result k) (the bit (logand byte 1)))))
  1270.     result))
  1271.  
  1272. (defun write-bitvector256 (buffer boffset map)
  1273.   (declare (type buffer buffer)
  1274.        (type array-index boffset)
  1275.        (type (simple-array bit (*)) map))
  1276.   (writing-buffer-send (buffer :index boffset :sizes 8)
  1277.     (do* ((i (index+ buffer-boffset 1) (index+ i 1))    ; Skip first byte
  1278.       (j 8 (index+ j 8)))        
  1279.      ((index>= j 256))
  1280.       (declare (type array-index i j))
  1281.       (do ((byte 0)
  1282.        (bit (index+ j 7) (index- bit 1)))
  1283.       ((index< bit j)
  1284.        (aset-card8 byte buffer-bbuf i))
  1285.     (declare (type array-index bit)
  1286.          (type card8 byte))
  1287.     (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
  1288.